home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / scamacr.scm < prev    next >
Text File  |  1999-04-19  |  7KB  |  182 lines
  1. ;;; "scamacr.scm" syntax-case macros for Scheme constructs
  2. ;;; Copyright (C) 1992 R. Kent Dybvig
  3. ;;;
  4. ;;; Permission to copy this software, in whole or in part, to use this
  5. ;;; software for any lawful purpose, and to redistribute this software
  6. ;;; is granted subject to the restriction that all copies made of this
  7. ;;; software must include this copyright notice in full.  This software
  8. ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
  9. ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
  10. ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
  11. ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
  12. ;;; NATURE WHATSOEVER.
  13.  
  14. ;;; Written by Robert Hieb & Kent Dybvig
  15.  
  16. ;;; This file was munged by a simple minded sed script since it left
  17. ;;; its original authors' hands.  See syncase.sh for the horrid details.
  18.  
  19. ;;; macro-defs.ss
  20. ;;; Robert Hieb & Kent Dybvig
  21. ;;; 92/06/18
  22.  
  23. (define-syntax with-syntax
  24.    (lambda (x)
  25.       (syntax-case x ()
  26.          ((_ () e1 e2 ...)
  27.           (syntax (begin e1 e2 ...)))
  28.          ((_ ((out in)) e1 e2 ...)
  29.           (syntax (syntax-case in () (out (begin e1 e2 ...)))))
  30.          ((_ ((out in) ...) e1 e2 ...)
  31.           (syntax (syntax-case (list in ...) ()
  32.                      ((out ...) (begin e1 e2 ...))))))))
  33.  
  34. (define-syntax syntax-rules
  35.    (lambda (x)
  36.       (syntax-case x ()
  37.          ((_ (k ...) ((keyword . pattern) template) ...)
  38.           (with-syntax (((dummy ...)
  39.                          (generate-temporaries (syntax (keyword ...)))))
  40.              (syntax (lambda (x)
  41.                         (syntax-case x (k ...)
  42.                            ((dummy . pattern) (syntax template))
  43.                            ...))))))))
  44.  
  45. (define-syntax or
  46.    (lambda (x)
  47.       (syntax-case x ()
  48.          ((_) (syntax #f))
  49.          ((_ e) (syntax e))
  50.          ((_ e1 e2 e3 ...)
  51.           (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
  52.  
  53. (define-syntax and
  54.    (lambda (x)
  55.       (syntax-case x ()
  56.          ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
  57.          ((_ e) (syntax e))
  58.          ((_) (syntax #t)))))
  59.  
  60. (define-syntax cond
  61.    (lambda (x)
  62.       (syntax-case x (else =>)
  63.          ((_ (else e1 e2 ...))
  64.           (syntax (begin e1 e2 ...)))
  65.          ((_ (e0))
  66.           (syntax (let ((t e0)) (if t t))))
  67.          ((_ (e0) c1 c2 ...)
  68.           (syntax (let ((t e0)) (if t t (cond c1 c2 ...)))))
  69.          ((_ (e0 => e1)) (syntax (let ((t e0)) (if t (e1 t)))))
  70.          ((_ (e0 => e1) c1 c2 ...)
  71.           (syntax (let ((t e0)) (if t (e1 t) (cond c1 c2 ...)))))
  72.          ((_ (e0 e1 e2 ...)) (syntax (if e0 (begin e1 e2 ...))))
  73.          ((_ (e0 e1 e2 ...) c1 c2 ...)
  74.           (syntax (if e0 (begin e1 e2 ...) (cond c1 c2 ...)))))))
  75.  
  76. (define-syntax let*
  77.    (lambda (x)
  78.       (syntax-case x ()
  79.          ((let* () e1 e2 ...)
  80.           (syntax (let () e1 e2 ...)))
  81.          ((let* ((x1 v1) (x2 v2) ...) e1 e2 ...)
  82.           (comlist:every identifier? (syntax (x1 x2 ...)))
  83.           (syntax (let ((x1 v1)) (let* ((x2 v2) ...) e1 e2 ...)))))))
  84.  
  85. (define-syntax case
  86.    (lambda (x)
  87.       (syntax-case x (else)
  88.          ((_ v (else e1 e2 ...))
  89.           (syntax (begin v e1 e2 ...)))
  90.          ((_ v ((k ...) e1 e2 ...))
  91.           (syntax (if (memv v '(k ...)) (begin e1 e2 ...))))
  92.          ((_ v ((k ...) e1 e2 ...) c1 c2 ...)
  93.           (syntax (let ((x v))
  94.                      (if (memv x '(k ...))
  95.                          (begin e1 e2 ...)
  96.                          (case x c1 c2 ...))))))))
  97.  
  98. (define-syntax do
  99.    (lambda (orig-x)
  100.       (syntax-case orig-x ()
  101.          ((_ ((var init . step) ...) (e0 e1 ...) c ...)
  102.           (with-syntax (((step ...)
  103.                          (map (lambda (v s)
  104.                                  (syntax-case s ()
  105.                                     (() v)
  106.                                     ((e) (syntax e))
  107.                                     (_ (syntax-error orig-x))))
  108.                               (syntax (var ...))
  109.                               (syntax (step ...)))))
  110.              (syntax-case (syntax (e1 ...)) ()
  111.                 (() (syntax (let doloop ((var init) ...)
  112.                                (if (not e0)
  113.                                    (begin c ... (doloop step ...))))))
  114.                 ((e1 e2 ...)
  115.                  (syntax (let doloop ((var init) ...)
  116.                             (if e0
  117.                                 (begin e1 e2 ...)
  118.                                 (begin c ... (doloop step ...))))))))))))
  119.  
  120. (define-syntax quasiquote
  121.    (letrec
  122.       ((gen-cons
  123.         (lambda (x y)
  124.            (syntax-case x (quote)
  125.               ((quote x)
  126.                (syntax-case y (quote list)
  127.                   ((quote y) (syntax (quote (x . y))))
  128.                   ((list y ...) (syntax (list (quote x) y ...)))
  129.                   (y (syntax (cons (quote x) y)))))
  130.               (x (syntax-case y (quote list)
  131.                    ((quote ()) (syntax (list x)))
  132.                    ((list y ...) (syntax (list x y ...)))
  133.                    (y (syntax (cons x y))))))))
  134.  
  135.        (gen-append
  136.         (lambda (x y)
  137.            (syntax-case x (quote list cons)
  138.               ((quote (x1 x2 ...))
  139.                (syntax-case y (quote)
  140.                   ((quote y) (syntax (quote (x1 x2 ... . y))))
  141.                   (y (syntax (append (quote (x1 x2 ...) y))))))
  142.               ((quote ()) y)
  143.               ((list x1 x2 ...)
  144.                (gen-cons (syntax x1) (gen-append (syntax (list x2 ...)) y)))
  145.               (x (syntax-case y (quote list)
  146.                    ((quote ()) (syntax x))
  147.                    (y (syntax (append x y))))))))
  148.  
  149.        (gen-vector
  150.         (lambda (x)
  151.            (syntax-case x (quote list)
  152.               ((quote (x ...)) (syntax (quote #(x ...))))
  153.               ((list x ...) (syntax (vector x ...)))
  154.               (x (syntax (list->vector x))))))
  155.  
  156.        (gen
  157.         (lambda (p lev)
  158.            (syntax-case p (unquote unquote-splicing quasiquote)
  159.               ((unquote p)
  160.                (if (= lev 0)
  161.                    (syntax p)
  162.                    (gen-cons (syntax (quote unquote))
  163.                              (gen (syntax (p)) (- lev 1)))))
  164.               (((unquote-splicing p) . q)
  165.                (if (= lev 0)
  166.                    (gen-append (syntax p) (gen (syntax q) lev))
  167.                    (gen-cons (gen-cons (syntax (quote unquote-splicing))
  168.                                        (gen (syntax p) (- lev 1)))
  169.                              (gen (syntax q) lev))))
  170.               ((quasiquote p)
  171.                (gen-cons (syntax (quote quasiquote))
  172.                          (gen (syntax (p)) (+ lev 1))))
  173.               ((p . q)
  174.                (gen-cons (gen (syntax p) lev) (gen (syntax q) lev)))
  175.               (#(x ...) (gen-vector (gen (syntax (x ...)) lev)))
  176.               (p (syntax (quote p)))))))
  177.  
  178.     (lambda (x)
  179.        (syntax-case x ()
  180.           ((- e) (gen (syntax e) 0))))))
  181.  
  182.